#-(or abcl sbcl)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (error "Unsupported Lisp implementation"))

(defpackage alef
  (:use :cl :doplus)
  (:import-from #+abcl :mop #+sbcl :sb-mop
                #:class-slots #:slot-definition-name #+abcl #:find-slot-definition
                #:standard-direct-slot-definition #:standard-effective-slot-definition
                #:direct-slot-definition-class #:effective-slot-definition-class
                #:compute-effective-slot-definition
                #:class-finalized-p #:finalize-inheritance)
  (:export #:defentity #:define-entity-metadata #:defrelation
           #:metadata-of #:metadata #:generate
           #:relation #:slot-relation #:relation-add #:relation-remove
           #:relation-to #:relation-from #:relation))

(in-package :alef)

(defclass with-metadata ()
  ((metadata :initarg :metadata :accessor metadata-of :initform nil)))

(defgeneric metadata (object metadata-name)
  (:method ((object with-metadata) metadata-name)
    (metadata (metadata-of object) metadata-name))
  (:method ((object list) metadata-name)
    (getf object metadata-name)))

(defun (setf metadata) (value object metadata-name)
  (setf (metadata-of object)
        (normalize-metadata (list* metadata-name value (metadata-of object)))))

(defun normalize-metadata (metadata)
  (do+ ((for key (in metadata :by #'cddr))
        (for value (in (cdr metadata) :by #'cddr))
        (collecting-into (keys md))
        (returning md))
    (when (not (find key keys))
      (collect key :into keys)
      (when value
        (collect key :into md)
        (collect value :into md)))))

(defgeneric initialize-metadata (metaobject key value))

(defmethod initialize-metadata (metaobject key value)
  (declare (ignore metaobject key))
  value)

(defun initialize-all-metadata (metaobject &optional (metadata (metadata-of metaobject)))
  (do+ ((for key (in metadata :by #'cddr))
        (for value (in (cdr metadata) :by #'cddr)))
    (collect key)
    (collect (initialize-metadata metaobject key value))))

(defclass with-metadata-on-slots (standard-class))

(defclass entity-class (standard-class with-metadata with-metadata-on-slots)
  ((defining-form :initarg :defining-form :accessor defining-form)))

(defmethod initialize-instance :after ((class entity-class) &key &allow-other-keys)
  (setf (metadata-of class) (initialize-all-metadata class)))

;;TODO: check metadata is a correct plist on initialize-instance and reinitialize-instance
;;TODO: merge slot metadata on redef!!!
(defmethod reinitialize-instance :around ((class entity-class) &rest initargs)
  (let ((new-md (getf initargs :metadata)))
    (if new-md
        (progn
          (apply #'call-next-method class
                 (substitute (normalize-metadata (append (initialize-all-metadata class new-md)
                                                         (metadata-of class)))
                             new-md
                             initargs)))
        (call-next-method))))

(defmethod initialize-instance :after ((class entity-class) &rest initargs)
  (declare (ignore initargs))
  (setf (defining-form class) (car (defining-form class)))) ;;Defclass wraps the option in an extra list

(defmacro defentity (&whole form name superclasses slots &rest options)
  (let ((metaclass (or (find :metaclass options :key #'car)
                       '(:metaclass entity-class))))
    `(defclass ,name ,superclasses ,slots (:defining-form ,form) ,@options
               ,metaclass)))

(defclass direct-slot-definition-with-metadata (standard-direct-slot-definition with-metadata) ())

(defmethod initialize-instance :after ((slot direct-slot-definition-with-metadata) &key &allow-other-keys)
  (setf (metadata-of slot) (initialize-all-metadata slot)))

(defclass effective-slot-definition-with-metadata (standard-effective-slot-definition with-metadata) ())

(defmethod direct-slot-definition-class ((class with-metadata-on-slots) &rest initargs)
  (declare (ignore class initargs))
  (find-class 'direct-slot-definition-with-metadata))

(defmethod effective-slot-definition-class ((class with-metadata-on-slots) &rest initargs)
  (declare (ignore class initargs))
  (find-class 'effective-slot-definition-with-metadata))

(defmethod compute-effective-slot-definition ((class with-metadata-on-slots) name direct-slots)
  (let ((slotdef (call-next-method)))
    (setf (metadata-of slotdef)
          (normalize-metadata (mapcan #'metadata-of direct-slots))) ;;More specific metadata comes before.
    slotdef))

(defun ensure-class-metaobject (c)
  (if (typep c 'class) c (find-class c)))

(defun add-metadata (metadata object-with-metadata)
  (setf (metadata-of object-with-metadata)
        (normalize-metadata (append metadata (metadata-of object-with-metadata)))))

#+sbcl
(defun find-slot-definition (class slot-name)
  (let ((slots (class-slots class)))
    (find slot-name slots :key #'slot-definition-name)))

(defmacro define-entity-metadata (class class-metadata slots-metadata)
  (let ((class-mobj (gensym)) (slot (gensym)))
    `(let ((,class-mobj (ensure-class-metaobject ',class)))
       (add-metadata (initialize-all-metadata ,class-mobj (list ,@class-metadata)) ,class-mobj)
       ,@(do+ ((for slot-md (in slots-metadata)))
           (collect
             `(let ((,slot (or (find-slot-definition ,class-mobj ',(car slot-md))
                               (error "Cannot set metadata for slot ~A because it does not exist in class ~A"
                                      ',(car slot-md) ,class-mobj))))
                (add-metadata (initialize-all-metadata ,slot (list ,@(cdr slot-md))) ,slot))))
       t)))

#+nil
(defentity some-class () (slot1 slot2))

#+nil
(let ((quux "quux"))
  (define-entity-metadata some-class
      ('table-name "SOME_DB_TABLE" 'xml-name "some-xml-tag-name")
    ((slot1 'foo 'bar :baz quux)
     (slot2 'some 42)
     #+foo (rel1 'relation '(:to bar :name rel1))))) ;Oppure: :to (bar bars-slot) x bidirezionalità?

#+nil
(alef:defentity b1 () ((s1 :metadata a b)) (:metadata x y z k))

#+sbcl
(defmethod sb-mop:validate-superclass ((class entity-class) (superclass standard-class))
  t)

;;Relations

(defclass relation (entity-class)
  ((from :initarg :from :accessor relation-from  :initform (error "from is required"))
   (to :initarg :to :accessor relation-to :initform (error "to is required"))
   (min :initarg :min :accessor relation-min :initform 0)
   (max :initarg :max :accessor relation-max :initform 1)))

;;Min, max TODO

(defclass relation-instance ()
  ((from :initarg :from :accessor relation-from  :initform (error "from is required"))
   (to :initarg :to :accessor relation-to :initform (error "to is required")))
  (:metaclass relation))

(defmacro defrelation (&whole form name from to &optional superclasses slots)
  `(defentity ,name (relation-instance ,@superclasses) (,@slots)
              (:metaclass relation) (:from ,from) (:to ,to) (:defining-form ,form))) ;;TODO check

(defun slot-relation (slot)
  (metadata slot 'relation))

(defun (setf slot-relation) (new-value slot)
  (setf (metadata slot 'relation) new-value)

;;TODO
#||
(defgeneric relation-add (a rel b) ;;e.g. (relation-add mike 'knows peter)
  (:argument-precedence-order rel a b))

(defmethod relation-add (a (rel symbol) b)
  (let ((slot (find-slot-definition (class-of a) rel)))
    (if (and slot (slot-relation slot))
        (relation-add a (slot-relation slot) b)
        (error "~S does not name a slot in ~S with an associated relation" rel a))))

(defgeneric relation-remove (a rel b)
  (:argument-precedence-order rel a b))

(defmethod relation-remove (a (rel symbol) b)
  (let ((slot (find-slot-definition (class-of a) rel)))
    (if (and slot (slot-relation slot))
        (relation-remove a (slot-relation slot) b)
        (error "~S does not name a slot in ~S with an associated relation" rel a))))

(defgeneric relation-reify (obj rel)
  (:documentation "Reifies a relation (not reified: employer --> employee, reified: employer --> contract (--> employee))")
  (:argument-precedence-order rel obj))

(defmethod relation-reify (obj (rel symbol))
  (let ((slot (find-slot-definition (class-of obj) rel)))
    (if (and slot (slot-relation slot))
        (relation-reify obj (slot-relation slot))
        (error "~S does not name a slot in ~S with an associated relation" rel obj))))
||#

(defgeneric relation-add (rel obj))

(defgeneric relation-remove (rel obj))

(defmethod finalize-inheritance :after ((class entity-class))
  (do+ ((for slot (in (class-slots class)))
        (for rel (being (slot-relation slot))))
    (when rel
      (setf (metadata slot 'relation)
            (cond
              ((symbolp rel) (find-class rel))
              ((typep rel 'class) rel)
              (t (error "Unsupported relation type: ~S~%" rel))))))) ;TODO

;;Generation

(defgeneric generate (entity what &rest args))

(defmethod generate (entity (what (eql 'instance)) &rest args)
  (apply #'make-instance entity args))

(defmethod generate ((entity symbol) what &rest args)
  (apply #'generate (find-class entity) what args))

(defmethod generate :before ((entity class) what &rest args)
  (declare (ignore what args))
  (unless (class-finalized-p entity)
    (finalize-inheritance entity)))

(defmacro generate-at-compile-time (what (&rest entities))
  `(progn
     ,@(do+ ((for x (in entities)))
         (if (atom x)
             (collect (generate x what))
             (collect (apply #'generate (car x) what (cdr x)))))))